home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / SysGen / forget < prev    next >
Encoding:
Text File  |  1992-01-22  |  4.3 KB  |  170 lines
  1. ( SMART FORGET ) 
  2.  
  3. \ 06-07-88 mdh ANDIFPROTECTED? prints name, incorporatd REHASH.
  4. \  MOD: PLB 09/09/88 Use found [FORGET]
  5. \  MOD: PLB 08/22/89 Make FORGET reclaim link field by adding
  6. \                    CELL- to (FORGET)
  7. \ 00001 mdh 04/24/91 adjust for new defered words
  8.  
  9. FORTH DEFINITIONS
  10. decimal
  11. \ INCLUDE? Y-OR-QUIT Y-OR-QUIT
  12. USER FORGOTTEN
  13.  
  14. : isuser?  ( cfa -- 0 / user# )    \ this is user-structure dependant!
  15.   >r ' s0  ( -- real-one )  ( --r-- maybe )
  16.   dup cell- @   r cell- @ = swap   ( -- flag real-one )
  17.         dup @         r @ =  swap  ( -- f1 f2 real )
  18.    6 +  dup @     r 6 + @ =  swap  ( -- f1 f1 f3 real )
  19.    drop and and
  20.    IF   r cell+ w@
  21.    ELSE false
  22.    THEN r> drop   ;
  23.  
  24. : yes?  .s  y/n  ;
  25.  
  26. : ANDIFPROTECTED? ( NFA --- flag )  dup >r   FENCE @ U<  dup
  27.    IF    drop  cr r@ id. ."  is protected. FORGET anyway? "  y/n 0=
  28.    THEN  0= rdrop  ;
  29.  
  30. : ?FORTH  ( NFA ---  ) CONTEXT @ U<
  31.    IF    FORTH DEFINITIONS
  32.    THEN  ;
  33.   
  34. : FORGET-VOCS ( NFA --- )  VOC-LINK 
  35.    BEGIN   @  2DUP  ( NFA VOC@ )   U> 
  36.    UNTIL   VOC-LINK ! DROP   ;
  37.  
  38. : FIX-VOC  ( NFA VLINK --- )   VLINK>VLATEST DUP>R @  ( V-NFA ) 
  39.     BEGIN  ( NFA  V-NFA )  2DUP U>   
  40.     WHILE-NOT  N>LINK  @
  41.     REPEAT  R>  ! DROP ;
  42.    
  43. : SET-VOC-LATESTS ( NFA --- )   VOC-LINK 
  44.    BEGIN  @ DUP
  45.    WHILE  ( NFA VLINK )  2DUP FIX-VOC
  46.    REPEAT 2DROP ;
  47.  
  48. variable highuser
  49.  
  50. : huser?  ( nfa -- )
  51.   name> isuser?  \ 00001 removed check if defered word (no longer uservar)
  52.   highuser @ max highuser !  ;
  53.  
  54. : (FORGET) ( --- , primary definition of forget )
  55.   DEFINITIONS
  56. \ replace   [] '  with following line to avoid using deferred FIND
  57.   bl word voc-find 0= 0 ?error
  58.   >NAME
  59.   dup  [ latest cell+ ] literal <
  60.   IF   .err ." Absolutely won't FORGET below FORGET!" quit
  61.   THEN
  62.   DUP  ANDIFPROTECTED?
  63.   IF   DUP ?FORTH  DUP FORGET-VOCS  DUP SET-VOC-LATESTS
  64. \ This was not reclaiming the link field.
  65. \       DP  !  FENCE @ HERE MIN FENCE ! TRUE FORGOTTEN !
  66.        CELL- DP  !  FENCE @ HERE MIN FENCE ! TRUE FORGOTTEN !
  67. \ following fixes cold-stuff...
  68.        maxvocs  coldvocnfas  #vocs @ 0
  69.        DO  dup @ here >
  70.            IF   ( #vocsleft coldvocnfa -- ) 2dup
  71.                 swap cells 2* erase  leave
  72.            ELSE [ 2 cells ] literal +     swap 1- swap
  73.            THEN
  74.        LOOP ( #vocsleft adr -- )   drop  maxvocs - abs #vocs !
  75. \ and, just to be safe, force cleaning up of any Long Relocation Tables...
  76.        ?forgotten
  77. \ and fixup user#
  78.        0 highuser !  ' huser? is when-scanned
  79.        ' drop is when-voc-scanned  scan-all-vocs
  80.        highuser @ cell+ user# !
  81. \ now check...are we forgetting below where COLD will crash?
  82.        here  dp +boots @ <
  83.        IF    freeze
  84.        THEN
  85.        Hash-Damaged on
  86.        hash.forget  ( in case there is a faster way )
  87.   ELSE drop
  88.   THEN
  89. \
  90. [ 1 .IF ]
  91.   FBLK @  CLINEFILE @ here >  and
  92.   IF
  93.      CLINEFILE @ dup>r odd@ $ ff,ff,ff and  $ 3a,3a,3a =
  94.      IF
  95.         r@ c@ $ 1f and r@ c!   r@ voc-find
  96.         IF
  97.            dup >name CLINEFILE !
  98.         THEN
  99.         drop
  100.      THEN
  101.      rdrop
  102.   THEN
  103. [ .THEN ]
  104. ;
  105.  
  106.  
  107. \ Link words together to be executed if forgotten.
  108. \
  109. \ If you forget one of these words
  110. \ it will execute a cleanup function.
  111. \
  112. \ For an example of this see JU:LOGTO and JU:MODULES
  113. \
  114. \ If you redefine [FORGET] you must call the old [FORGET]
  115. \ from the new one.
  116. \
  117. \ Author: Phil Burk
  118. \ Copyright 1988 Phil Burk
  119.  
  120. variable last-forget
  121.  
  122. : IF.FORGOTTEN ( <name> -- , place links in dictionary without header)
  123.     32 word find
  124.     IF here  last-forget @ , \ Cell 1 = back link to previous 
  125.       last-forget !
  126.       ,   ( save cfa )       \ Cell 2 = cfa to call if forgotten
  127.     ELSE ." IF.FORGOTTEN couldn't find " here count type cr
  128.     THEN
  129. ;
  130.  
  131. if.forgotten noop
  132.  
  133. : [FORGET] ( -- , forget then exec forgotten words)
  134.     (FORGET)
  135.     last-forget
  136.     BEGIN @ dup 0>
  137.     WHILE dup here >
  138.         IF dup cell+ @execute
  139.         ELSE last-forget ! RETURN
  140.         THEN
  141.     REPEAT drop
  142. ;
  143.  
  144.  
  145. : FORGET ( -- , execute latest [forget] )
  146.     " [FORGET]" find
  147.     IF execute
  148.     ELSE count type ." not found!" cr
  149.     THEN
  150. ;
  151.  
  152. : ANEW ( <word> -- , forgets if defined, redefines )
  153.     >in @
  154.     bl word find
  155.     IF over >in ! forget
  156.     THEN drop
  157.     >in !   variable
  158. ;
  159.  
  160. : COLD  ( -- , cleanup 'IF.FORGOTTEN' words... )
  161.   last-forget
  162.   BEGIN @ dup 0>
  163.   WHILE dup fence @ >
  164.       IF dup cell+ @execute
  165.       ELSE last-forget ! cold
  166.       THEN
  167.   REPEAT drop
  168.   cold
  169. ;
  170.